{-# LANGUAGE FlexibleInstances,
             MultiParamTypeClasses,
             DeriveDataTypeable,
             RecordWildCards
             #-}

module Main where

import Control.Monad ( void )
import Data.Text
import Data.Text.IO ( hPutStr )
import Network.Server
import Network.Socket ( PortNumber )
import qualified Network.Socket as Sock
import System.Console.CmdLib
import qualified System.Console.CmdLib as Cmd
import System.IO ( hGetChar, hFlush, hClose )
import qualified System.Posix.Daemonize as Posix

import Debug.Trace ( trace )


data Config = Config { port :: Int, daemon :: Bool }
    deriving (Typeable, Data, Eq)

instance Attributes Config where
  attributes _ = Cmd.group "Options"
      [ port   %> Help "Port number." %+ ArgHelp "PORT" %+ short 'p' %+ Default (4000::Int)
      , daemon %> Help "Daemonize" %+ Long ["daemonize"] %+ short 'd'
      ]


mkFlashPolicyServer :: PortNumber -> Server
mkFlashPolicyServer port
  = Server {
      serverAddr    = Sock.SockAddrInet port Sock.iNADDR_ANY
    , serverTyp     = Sock.Stream
    , serverRoutine = provideFlashPolicy
    }
  where flash_policy = pack $
             "<?xml version=\"1.0\"?>"
          ++ "<!DOCTYPE cross-domain-policy SYSTEM \"http://www.adobe.com/xml/dtds/cross-domain-policy.dtd\">"
          ++ "<cross-domain-policy>"
          ++ "  <site-control permitted-cross-domain-policies=\"master-only\"/>"
          ++ "  <allow-access-from domain=\"*\" to-ports=\"*\"/>"
          ++ "</cross-domain-policy>\NUL"
        read_stuff buf hdl = do
          c <- hGetChar hdl
          if c == '\0' then return buf else read_stuff (buf ++ [c]) hdl
        provideFlashPolicy (hdl,_,_) = trace ("new connection") $ do
          request <- read_stuff "" hdl
          trace ("new request = " ++ request) $ hPutStr hdl flash_policy
          hFlush hdl
          trace ("XML sent = " ++ show flash_policy) $ hClose hdl


data FlashPolicy = FlashPolicy deriving Typeable

instance Command FlashPolicy (Record Config) where
  run _ conf _ = daemonize $ do
    let flashPolicyServer = mkFlashPolicyServer (fromIntegral $ port conf)
    flashPolicy <- serveOne Nothing flashPolicyServer
    waitFor flashPolicy
    where daemonize | daemon conf = Posix.daemonize
                    | otherwise   = id

main :: IO ()
main = getArgs >>= execute FlashPolicy
